home *** CD-ROM | disk | FTP | other *** search
/ Aminet 3 / Aminet 3 - July 1994.iso / Aminet / dev / lang / J4thDemo.lha / Programs / show_iff < prev    next >
Encoding:
Text File  |  1992-09-05  |  3.3 KB  |  168 lines
  1. \ Show IFF ILBM File
  2. \ Use deferred IFF parsing words to parse file,
  3. \ create bitmap and make screen from bitmap.
  4. \
  5. \ Author: Phil Burk
  6. \ Copyright 1987 Phil Burk
  7. \
  8. \ MOD: PLB 12/7/90 Added SW-HI SW-WIDE to SCREEN>BACKWINDOW
  9. \      Thanks to Marty Kees
  10. \ MOD: PLB 9/91 Moved SCREEN>WINDOW etc. to JU:SCREEN_SUPPORT
  11. \ MOD: PLB 10/25/91 Changed ERROR to ERR in $IFF.DISPLAY
  12. \          to avoid naming conflict.
  13. \ 00001 PLB 11/13/91 Explicitly close SIFF-WINDOW
  14.  
  15. getmodule includes
  16. include? gr.init ju:amiga_graph
  17. include? ?closebox ju:amiga_events
  18. include? newscreen.setup ju:screen_support
  19. \
  20. include? unpackrow jiff:unpacking
  21. include? IFF.DOFILE jiff:iff_support
  22. include? task-ilbm_parser jiff:ilbm_parser
  23.  
  24. decimal
  25. ANEW TASK-SHOW_IFF
  26.  
  27. variable SIFF-SCREEN  ( holder for relative screen pointer )
  28. variable SIFF-WINDOW  \ 00001
  29.  
  30. : SIFF.SHOWIT ( -- , Put window display in front for closebox.)
  31.     siff-Screen @ true showtitle()
  32.     siff-Screen @ false showtitle()
  33. ;
  34.  
  35. : SIFF.CLOSE ( -- , Close screen and window.)
  36.     siff-window @ ?dup \ 00001
  37.     IF
  38.         gr.closewindow siff-window off
  39.     THEN
  40.     siff-Screen @ ?dup
  41.     IF
  42.         closescreen()  siff-Screen off
  43.     THEN
  44. ;
  45.  
  46. 32 constant SIFF_MAX_COLORS
  47. create siff-ctable siff_max_colors 2* allot
  48.  
  49. : SIFF.USE.CTABLE ( ctable #colors -- )
  50.     siff-Screen @ .. sc_viewport -rot
  51.     loadRGB4()
  52. ;
  53.  
  54. : SIFF.BLACKOUT ( -- , black out colors on screen )
  55.     siff-screen @ .. sc_viewport
  56.     ..@ vp_colormap >rel ..@ cm_count
  57.     siff-ctable over 2* erase  ( clear color table )
  58.     siff-ctable swap siff.use.ctable
  59. ;
  60.  
  61. : SIFF.USE.CMAP ( cmap cmsize -- )
  62.     pad swap
  63.     3 / dup>r
  64.     cmap>ctable
  65.     pad r> siff.use.ctable
  66. ;
  67.  
  68. : SIFF.WAIT ( -- , wait for event )
  69.     BEGIN ?closebox ?terminal OR
  70.     UNTIL
  71. ;
  72.  
  73. : SIFF.ABORT
  74.     ilbm.cleanup
  75.     ." IFF parsing aborted" cr
  76.     abort
  77. ;
  78.  
  79. : $IFF>BITMAP ( $filename -- bitmap | NULL , read )
  80.     gr.init
  81. \ Read graphics from file.
  82.     $ilbm.parse.file?
  83.     IF
  84.         0
  85.     ELSE
  86.         ilbm.alloc.bitmap dup
  87.         IF  dup ilbm.fill.bitmap 0=
  88.             IF free.bitmap 0
  89.             THEN
  90.         THEN
  91.     THEN
  92.     ilbm.cleanup
  93. ;
  94.  
  95. : IFF>BITMAP ( <filename> -- bitmap | NULL , read IFF file )
  96.     fileword $iff>bitmap
  97. ;
  98.  
  99. : $IFF>DISPLAY { $filename | bmap scr wnd -- bitmap | NULL , read and open}
  100.     gr.init
  101.     siff.close
  102.     0 -> bmap
  103. \
  104. \ Read graphics from file.
  105.     $filename $ilbm.parse.file? ?goto.error
  106.     ilbm.alloc.bitmap -> bmap
  107.     bmap 0= ?goto.error
  108. \
  109. \ Create proper screen
  110.     bmap clear.bitmap
  111.     bmap ilbm-camg @ bitmap>screen -> scr
  112.     scr 0=
  113.     IF 
  114.         ." Couldn't open screen!" cr
  115.         goto.error
  116.     THEN
  117. \
  118. \ Set up backdrop window
  119.     scr siff-screen !
  120.     scr screen>backwindow -> wnd
  121.     wnd 0=
  122.     IF
  123.         ." Couldn't open window!" cr
  124.         goto.error
  125.     THEN
  126.     
  127.     wnd siff-window ! \ 00001
  128.     ilbm-cmap @  ( set colors )
  129.     IF ilbm-cmap @ ilbm-cmsize @ siff.use.cmap
  130.     THEN
  131.     siff.showit
  132. \
  133. \ Now that it's safe, load graphics into bitmap.
  134.     bmap ilbm.fill.bitmap 0= ?goto.error
  135.     ilbm.cleanup
  136.     bmap
  137.     exit
  138. \
  139. ERROR:
  140.     ilbm.cleanup
  141.     siff.close
  142.     bmap
  143.     IF bmap free.bitmap
  144.     THEN
  145.     0
  146. ;
  147.  
  148. : IFF>DISPLAY ( <filename> -- bitmap , open a screen and display )
  149.     fileword $iff>display
  150. ;
  151.  
  152. : JSHOW  ( <filename> -- , read an IFF file, show and close)
  153.     gr.init
  154.     >newline ." JSHOW V3.0 - By Phil Burk, written in JForth" cr
  155.     ilbm.init
  156.     iff>display ?dup
  157.     IF  siff.wait
  158.         siff.close
  159.         free.bitmap
  160.     THEN
  161.     gr.term
  162. ;
  163.  
  164. cr ." Enter:   JSHOW <filename>   to see an IFF file." cr
  165. cr ."          (click top-left corner to exit)" cr
  166. cr ." NOTE:  to see the provided picture,  enter:" cr
  167. cr ."            JSHOW JFORTH_DEMO:TUTORIALS/STORM.IFF" cr cr
  168.